home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / edebug / edebug-test.el.z / edebug-test.el
Encoding:
Text File  |  1998-05-21  |  22.0 KB  |  1,190 lines

  1. ;; Some tests for edebug.
  2.  
  3. ;;=======================
  4. ;; Reading tests.
  5.  
  6. (testing (one two) three)
  7.  
  8. (progn '(testing))
  9.  
  10. (a . (b . c))
  11.  
  12. (a . "test")
  13.  
  14. (a . (b . nil))
  15.  
  16. (a . [one two three])
  17.  
  18. ;;===========================
  19. ;; Backquote test
  20.  
  21. (defun test ()
  22.  (macroexpand '(` ((, (a)) . (, test))))
  23. )
  24. (test)
  25.  
  26. (progn (` ((, (point)) . (, (point)))))
  27. (` (, (point)))
  28.  
  29. (defun test ()
  30. (message "%d" 999999)
  31.  
  32. (defun test1 ()
  33.  
  34.   (progn
  35.     (defun test ()
  36.       (message "%d" 99999))
  37.     (test)
  38.     )
  39.  
  40.   )
  41. (test1)
  42. (test)
  43.  
  44. (eval (edebug-` (append [(, (point)) (, (point))] nil)))
  45. (eval (edebug-` (append (, (point)) (, (point)) nil)))
  46.  
  47. (eval (progn (edebug-` (edebug-` (, '(, (point)))))))
  48.  
  49. (eval (edebug-` (let (((, 'a) 'b))
  50.           (message "%s" a))))
  51.  
  52. (defun test ()
  53.  
  54. (let ((r '(union x y)))
  55.    (` (` (foo (, '(, r))))))
  56. )
  57.  
  58. (defun test ()
  59.  (let ((a '(one two))) a))
  60.  
  61. (def-edebug-spec test-func (sexp &rest def-form))
  62.  
  63. (setq edebug-unwrap-results t)
  64. (setq edebug-unwrap-results nil)
  65.  
  66. (defmacro test-func (func &rest args)
  67.   (edebug-` ((, func) (,@ args))))
  68.  
  69. (test-func message (concat "hi%s" "there") (+ 1 2))
  70.  
  71. (defmacro test-progn (&rest body)
  72.   (edebug-` (progn (,@ body))))
  73.  
  74. (def-edebug-spec test-progn (&rest def-form))
  75.  
  76. (test-progn
  77.  (message "testing"))
  78.  
  79.  
  80. ;;=================
  81. ;; Testing read syntax.
  82.  
  83. (format "testing %s %s %s" 1 2 (+ 1 2))
  84.  
  85. (defun test-syntax ()
  86.   (setq mode-line-stuff'("draft(%b) ^C^S(end) ^C^Q(uit) ^C^K(ill)"))
  87. ;;  (re-search-forward "[.?!][])""']*$" nil t)
  88. ;;  (let (test)
  89.     )
  90. )
  91.  
  92. (test-syntax)
  93.  
  94. (let ())
  95. ;;====================
  96. ;; Testing function
  97.  
  98. (defun foo (x)
  99.   (mapconcat (function identity) x ", "))
  100.  
  101. (defun foo (x)
  102.   (mapconcat 'identity x ", "))
  103.  
  104. (defun foo (x)
  105.   (mapconcat (function (lambda (x) x)) x ", "))
  106.  
  107. (require 'cl)
  108.  
  109. (defun foo (x)
  110.   (mapconcat (function* (lambda (x &optional (y (1+ x)) &key xyz) x)) x ", "))
  111.  
  112. (defun foo (x)
  113.   (mapconcat '(lambda (x) x) x ", "))
  114.  
  115. (foo '(1 2 3))
  116.  
  117. (apply 'identity one two)
  118.  
  119. (defun test1 (arg)
  120.   arg)
  121.  
  122. (def-edebug-spec test1
  123.   (form))
  124. (setq x 5)
  125. (test1 (+ x 2))
  126.  
  127.   (("test1" test1)))
  128.  
  129. (def-edebug-spec test1
  130.   (&define sexp form))
  131.  
  132. (test (test1 xyz (message "jfdjfd")))
  133.  
  134. ;;====================
  135. ;; Anonymous function test
  136. (defun hej (arg)
  137.   "docstring"
  138.   (interactive (list 2))
  139.   ((lambda (luttr &rest params)
  140.      (apply luttr luttr params))
  141.    (function (lambda (self n)
  142.            (edebug-trace "n: %s" n)
  143.            (if (= n 5) (edebug nil "n is 5"))
  144.            (edebug-tracing "cond"
  145.         (cond
  146.          ((= 0 n) 1)
  147.          (t (* n (funcall self self (1- n))))))))
  148.    11))
  149.  
  150. (defun hej-test ()
  151.   (interactive)
  152.   (message 
  153.    "testing")
  154.   (hej edebug-execution-mode)
  155.   )
  156. (hej-test)
  157.  
  158. (defun lambda-test ()
  159.   ((lambda (arg) arg) 'xyz))
  160. (lambda-test)
  161.  
  162. (defun test ()
  163.   "doc string
  164.  (with left paren on start of line)"
  165.  
  166.   1)
  167.  
  168.  
  169. (progn
  170.   (save-window-excursion
  171.     (split-window)
  172.     (split-window)
  173.     (setq w (next-window)))
  174.   (edebug-window-live-p w))
  175.  
  176.  
  177. ;;====================
  178. ;; Test edebugging top-level-forms
  179.  
  180. (def-edebug-spec test nil)
  181. (let ((arg (list 'a 'b 'c)))
  182.   (defun test (arg)
  183.     arg)
  184.   (test arg))
  185.  
  186.  
  187. (fset 'emacs-setq (symbol-function 'setq))
  188.  
  189. (defmacro my-setq (&rest args)
  190.   (while args
  191.     (set (car args) (eval (car (cdr args))))
  192.     (setq args (cdr (cdr args)))))
  193.  
  194. (defmacro test-macro (&rest args)
  195.   (cons 'list args))
  196. (def-edebug-spec test-macro 0)
  197.  
  198. (defun test ()
  199.   (test-macro (message "testing")))
  200. (test)
  201.  
  202. (defun test ()
  203.   (message "someting")
  204.   (function (lambda ()
  205.           (message "something else")))
  206.   )
  207.  
  208. (funcall (test))
  209.  
  210. ;;====================
  211. ;; Test for and inc
  212. (def-edebug-spec for
  213.   (symbolp ["from" def-form ["to" def-form] ["do" &rest def-form]]))
  214.  
  215.  ;; (symbolp ['from form ['to form] ['do &rest form]])
  216.  
  217. (inc x)
  218. (defmacro inc (var)
  219.   (list 'setq var (list '1+ var)))
  220.  
  221. (defmacro for (var from init to final do &rest body)
  222.   (let ((tempvar (make-symbol "max")))
  223.     (edebug-` (let (((, var) (, init))
  224.             ((, tempvar) (, final)))
  225.         (while (<= (, var) (, tempvar))
  226.           (,@ body)
  227.           (inc (, var)))))))
  228.  
  229. (defun test-for (one two)
  230.   (for i from one to two do
  231.        (message "%s" i))
  232.   )
  233.  
  234. (let ((n 5))
  235.   (for i from n to (* n (+ n 1)) do
  236.     (message "%s" i)))
  237.  
  238. (test-for 3 10)
  239.  
  240. ;;====================
  241. ;; Test condition-case
  242. (def-edebug-spec condition-case
  243.   (symbolp
  244.    form
  245.    &rest (symbolp &optional form)))
  246.  
  247. (setq edebug-on-signal '(error))
  248.  
  249. (defun test-condition-case ()
  250.   (condition-case err
  251.       (signal 'error '(oh))
  252.     (error (message "error: %s" err))
  253.     ))
  254. (test-condition-case)
  255.  
  256. (require 'cl)
  257.  
  258. ;;=============
  259. ;; lexical let
  260.  
  261. (defun test-lexical ()
  262.   (funcall (lexical-let ((xyz 123))
  263.          (function (lambda (arg) (+ arg xyz))))
  264.        456))
  265. (test-lexical)
  266.  
  267. ;;====================
  268. ;; case test.
  269. (defun test-case (one)
  270.   (case one
  271.     ((one) (message "(one)"))
  272.     ("one" (message "one"))
  273.     ('one (message "'one"))
  274.     ))
  275.  
  276. (test-case 'one)
  277.  
  278. ;;====================
  279. ;; Test of do from cl.el
  280.  
  281. (defun list-reverse (list)
  282.   (do ((x list (cdr x))
  283.        (y nil (cons (car x) y)))
  284.       ((endp x) y)
  285.     (message "x: %s  y: %s" x y)
  286.     ))
  287.  
  288.  
  289. (list-reverse '(testing one two three))
  290.  
  291. (defmacro test-backquote (arg list)
  292.   (edebug-` 
  293.    (progn
  294.      (message "%s %s" (, arg) (, list))
  295.      (mapcar (function (lambda (arg1) 
  296.              (message "%s %s" arg1 (, arg)))) (, list)))))
  297.  
  298. (def-edebug-spec test-backquote (def-form def-form))
  299. (test-backquote (symbol-name 'something) (list 1 2 3))
  300.  
  301.  
  302. (defmacro dired-map-over-marks (body arg &optional show-progress)
  303.   (edebug-` (prog1
  304.      (let (buffer-read-only case-fold-search found results)
  305.        (if (, arg)
  306.            (if (integerp (, arg))
  307.            (progn;; no save-excursion, want to move point.
  308.              (dired-repeat-over-lines
  309.               (, arg)
  310.               (function (lambda ()
  311.                   (if (, show-progress) (sit-for 0))
  312.                   (setq results (cons (, body) results)))))
  313.              (if (< (, arg) 0)
  314.              (nreverse results)
  315.                results))
  316.          ;; non-nil, non-integer ARG means use current file:
  317.          (list (, body)))
  318.          (let ((regexp (dired-marker-regexp)) next-position)
  319.            (save-excursion
  320.          (goto-char (point-min))
  321.          ;; remember position of next marked file before BODY
  322.          ;; can insert lines before the just found file,
  323.          ;; confusing us by finding the same marked file again
  324.          ;; and again and...
  325.          (setq next-position (and (re-search-forward regexp nil t)
  326.                       (point-marker))
  327.                found (not (null next-position)))
  328.          (while next-position
  329.            (goto-char next-position)
  330.            (if (, show-progress) (sit-for 0))
  331.            (setq results (cons (, body) results))
  332.            ;; move after last match
  333.            (goto-char next-position)
  334.            (forward-line 1)
  335.            (set-marker next-position nil)
  336.            (setq next-position (and (re-search-forward regexp nil t)
  337.                         (point-marker)))))
  338.            (if found
  339.            results
  340.          (list (, body))))))
  341.        ;; save-excursion loses, again
  342.        (dired-move-to-filename))))
  343.  
  344.  
  345. (def-edebug-spec dired-map-over-marks (&rest def-form))
  346.  
  347. (dired-map-over-marks
  348.  (message "here") (+ 1 2) t)
  349.  
  350. ;;====================
  351. ;; circular structure test
  352.  
  353. (edebug-install-custom-print)
  354. (edebug-uninstall-custom-print)
  355.  
  356. (setq a '(1 2))
  357. (progn
  358.   (edebug-install-custom-print)
  359.   (setq a '(1 2))
  360.   (setcar a a))
  361.  
  362. (defun test ()
  363.   (with-custom-print
  364.      (format "%s" (setcar a a)))))
  365. (test)
  366. (setcdr a a)
  367. (let ((b a)) b)
  368.  
  369. (with-custom-print
  370.  (let ((print-circle t)
  371.        (circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f)))
  372.    (setcar (nthcdr 3 circ-list) circ-list)
  373.    (aset (nth 2 circ-list) 2 circ-list)
  374.    (prin1-to-string circ-list)))
  375.  
  376. ;;====================
  377. ;; interactive-p test
  378. (defun test-interactive ()
  379.   (interactive)
  380.   (interactive-p))
  381.  
  382. (test-interactive)
  383. (call-interactively 'test-interactive)
  384.  
  385.  
  386. ;;====================
  387. ;; test several things:
  388. ;; - nested defun.
  389. ;; - display scrolling.
  390.  
  391.  
  392. (defmacro testmacro ()
  393.   '(interactive-p))
  394.  
  395. (call-interactively 'testing1)
  396. (testing1 9)
  397.  
  398. (defun testing1 (arg)
  399.   (interactive (list 3))
  400.   (message "%s" (interactive-p)) (sit-for 2)
  401.   (edebug-trace "interactive: %s" (testmacro))
  402.   (defun testing1-1 ()
  403.     (testing1 2))
  404. ;;  (custom-message "%s" arg "extra")
  405.   (current-buffer)
  406.   (selected-window)
  407.   (while (< 0 (setq arg (1- arg)))
  408.   arg
  409.   arg
  410.   arg
  411.   arg
  412.   arg
  413.   arg
  414.   arg
  415.   arg
  416.   arg ; middle
  417.   arg
  418.   arg
  419.   arg
  420.   arg
  421.   arg
  422.   arg
  423.   arg
  424.   arg
  425.   arg
  426.   arg   ; jump
  427.   arg
  428.   arg
  429.   arg
  430.   arg
  431.   arg
  432.   arg
  433.   arg
  434.   arg
  435.   arg
  436.   arg
  437.   arg
  438.   arg
  439.   arg
  440. ))
  441. (edebug-trace-display "*testing*" "one")
  442. (edebug-tracer "one\n")
  443.  
  444. (testing1 a)
  445. (call-interactively 'testing1)
  446. (testing1 2)
  447.  
  448. (testing1-1)
  449.  
  450.  
  451. (defmacro testmacro ()
  452.   (interactive)
  453.   '(one))
  454.  
  455. (defun testing2 ()
  456.   (let* ((buf (get-buffer-create "testing"))
  457.      (win (get-buffer-window buf)))
  458.     (testing1 1) 
  459.     (window-point win)
  460.     (window-point win)
  461.  
  462. ;;    (read-stream-char buf)
  463.     ))
  464.  
  465. (testing2)
  466.  
  467.  
  468. (defun testing3 ()
  469.   (save-excursion
  470.     (set-buffer (get-buffer-create "*testing*"))
  471.     (current-buffer)
  472.     (point)
  473.     (forward-char 1)
  474.     ))
  475. (testing3)
  476.  
  477.  
  478. ;;====================
  479. ;; anonymous function test
  480. (defun testanon (arg)
  481.   (mapcar '(lambda (x) x) arg)
  482.   (mapcar (function (lambda (x) x)) arg)
  483.   (mapcar (function testing3 ) arg)
  484.   )
  485.  
  486. (testanon '(1 2 3))
  487.  
  488. ;;====================
  489. ;; upward funarg test
  490.  
  491. (defmacro lambda (&rest args)
  492.   "Return the quoted lambda expression."
  493.   (cons 'function (list (cons 'lambda args))))
  494.  
  495. (lambda (testing) one two)
  496.  
  497. (defun testanon2 ()
  498.   "return an anoymous function."
  499.   (function (lambda (x) x))
  500.   )
  501. ;; Emacs 19 has a lambda macro
  502. (defun testanon2 ()
  503.   "return an anoymous function."
  504.   (lambda (x) x))
  505. (testanon2)
  506.  
  507. (setq func
  508.       (testanon2))
  509. (funcall func 2)
  510.  
  511. (defun foo ()
  512.   (mapcar #'(lambda (x)
  513.           (message "%S" x))
  514.       (append '(0) '(a b c d e f))))
  515. (foo)
  516.  
  517. ;;====================
  518. ;; downward funarg test
  519.  
  520. (defun xxx (func)
  521.   (funcall func))
  522.  
  523. (defun yyy ()
  524.   (xxx (function (lambda () (message "hello")))))
  525.  
  526. (yyy)
  527.  
  528. ;; eval this:
  529. (def-edebug-spec test nil)
  530. (defun test (func list)
  531.   (dolist (el list)
  532.     (funcall func el)))
  533.  
  534. ;; edebug this:
  535. (defun testcall (l)
  536.   (test (function (lambda (x) (print x)))  ;; set breakpoints in anon.
  537.     l))
  538.  
  539. ;; test call: 
  540. (testcall '(a b c))
  541.  
  542. ;; flet test.
  543.  
  544. (defun alep-write-history (&rest args)
  545.   (message "alep-write-history( %s )\n"
  546.        args)
  547.   ;; write out header
  548.   '(write-region (format ";;Saved on %s\n" (current-time-string))
  549.         nil buffer-file-name nil 'shut-up)
  550.   ;; dump all not deleted actions
  551.   (flet ((write-solution (sol)
  552.       t)
  553.      (write-action (action)
  554.       (if (a-h-action-deleted action)
  555.           ;; nothing to be done
  556.           t
  557.         (write-region
  558.          (format "(alep-new-history-action %S %S %S)\n"
  559.              (a-h-action-name action)
  560.              (alep-tnowv-string (a-h-action-in-tnowv
  561.                      action))
  562.              (a-h-action-timestamp action))
  563.          nil buffer-file-name t 'shut-up)
  564.         (mapc 'write-solution
  565.           (a-h-action-solutions action)))))
  566.     (mapc 'write-action
  567.       history-list))
  568.   t)
  569. (setq history-list '(1 2 3))
  570. (alep-write-history)
  571.  
  572. ;;=========================
  573.  
  574.   (edebug-trace "my stuff")
  575.  
  576. (defun fac (n)
  577.   (if (= n 0) (edebug))
  578. ;#6           1      0 =5 
  579.   (if (< 0 n)
  580. ;#5         = 
  581.       (* n (fac (1- n)))
  582. ;#    5               0  
  583.     1))
  584. ;#   0 
  585.  
  586. (fac 5)
  587.  
  588.  
  589. ;;====================
  590. ;; Timing test - how bad is edebug?
  591.  
  592. (defun looptest (n)
  593.   (let ((i 0))
  594.     (while (< i n) (setq i (1+ i)))))
  595.  
  596. (looptest 10000)
  597.  
  598. ;;====================
  599. ;; eval-depth testing.
  600.  
  601. (defun test-depth (i)
  602.   (test-depth (1+ i)))
  603.  
  604. ;; Without edebug i reaches 193, failing on eval depth
  605. ;; With edebug, i reaches about 57.  Better safe than sorry.
  606. (setq max-lisp-eval-depth 200)
  607. (test-depth 0)
  608.  
  609. ;;====================
  610. ;; specpdl-size testing.
  611. (defun test-depth2 (i max)
  612.   (let ((test max-specpdl-size)
  613.     (max-lisp-eval-depth (+ 2 max-lisp-eval-depth))
  614.     )
  615.     (test-depth2 (1+ i) max-specpdl-size)))
  616.  
  617. (let ((max-lisp-eval-depth 300)
  618.       (max-specpdl-size 3))
  619.   (test-depth2 0 max-specpdl-size))
  620.  
  621. ;;====================
  622. ;; Buffer testing.
  623.  
  624. (defun zprint-region-1 (start end switches)
  625.   (let ((name (concat (buffer-name) ""))
  626.         (width tab-width))
  627.     (save-excursion
  628.       (message "Spooling...")
  629.       (let ((oldbuf (current-buffer)))
  630.         (set-buffer (get-buffer-create " *spool temp*"))
  631.         (widen)
  632.         (erase-buffer)
  633.         (insert-buffer-substring oldbuf start end)
  634.         (setq tab-width width)
  635.         (if (/= tab-width 8)
  636.             (untabify (point-min) (point-max)))
  637.         (setq start (point-min) end (point-max)))
  638.       (apply 'call-process-region
  639.              (nconc (list start end zpr-command nil nil nil
  640.                           "-h" name switches)))
  641.       (message "Spooling...done")
  642.       )
  643.     )
  644.   )
  645.  
  646.  
  647.  
  648. (defun quick-hanoi (nrings)
  649.   (with-output-to-temp-buffer "*hanio*"
  650.     (set-buffer "*hanio*")
  651.     (princ (format "Solution to %s ring hanoi problem\n\n" nrings))
  652.     (hanoi0 nrings 'pole-1 'pole-2 'pole-3)))
  653.  
  654. (defun hanoi0 (n from to work)
  655. ;;  (edebug-set-window-configuration (edebug-current-window-configuration))
  656.   (if (> n 0)
  657.       (progn
  658. ;;    (save-excursion
  659. ;;      (set-buffer "*hanio*")
  660. ;;      (message "Point=%s window-point=%s" (point)
  661. ;;           (window-point (get-buffer-window "*hanio*")))
  662. ;;      (set-window-point (get-buffer-window "*hanio*") (point))
  663. ;;      )
  664.     
  665.     (hanoi0 (1- n) from work to)
  666.     (princ (format "ring %s from %s to %s\n" n from to))
  667.     (hanoi0 (1- n) work to from))))
  668.  
  669. (quick-hanoi 5)
  670.  
  671.  
  672. ;;====================
  673. ;; Error test
  674.  
  675. (defun error-generating-function ()
  676.   (message "try again?") (sit-for 1)
  677.   (prog1
  678.       (signal 'bogus '("some error" xyz abc))
  679.       (error "debug-on-error: %s edebug-entered: %s edebug-recursion-depth: %s"
  680.          debug-on-error edebug-entered edebug-recursion-depth)))
  681.  
  682. ;; --><-- point will be left between the two arrows
  683. (setq debug-on-error nil)
  684. (setq edebug-on-signal '(bogus))
  685.  
  686. (testing-function)
  687. (defun testing-function ()
  688.   (interactive)
  689.   (message "YYY")
  690.   (error-generating-function)
  691.   (message "ZZZ"))
  692.  
  693.  
  694. (let ((debug-on-error t))
  695.   xyzzyz)
  696.  
  697. ;;====================
  698. ;; Quitting with unwind-protect
  699.  
  700. (defun unwind-test ()
  701.   (prog1
  702.       (unwind-protect
  703.       (unwind-protect
  704.           (message "testing")
  705.         (message "unwinding1"))
  706.     (message "unwinding2")
  707.     (sit-for 1)
  708.     )
  709.     ))
  710. (unwind-test)
  711.  
  712. (defmacro save-buffer-points (&rest body)
  713.   (` (let ((buffer-points
  714.         (mapcar (function (lambda (buf)
  715.                 (set-buffer buf)
  716.                 (cons buf (point))))
  717.             (buffer-list))))
  718.        (unwind-protect
  719.        (progn
  720.          (,@ body))
  721.      (mapcar (function (lambda (buf-point)
  722.                  (if (buffer-name (car buf-point))
  723.                  (progn
  724.                    (set-buffer (car buf-point))
  725.                    (goto-char (cdr buf-point))))))
  726.          buffer-points)))))
  727.  
  728. (defun testing4 ()
  729.   (with-output-to-temp-buffer "*testing*"
  730.     (princ "Line 1\n")
  731.     (save-buffer-points
  732.       (recursive-edit)
  733.       )
  734.     (princ "Line 2\n")
  735.     ))
  736.  
  737. (testing4)
  738. test!
  739.  
  740.  
  741. ;;====================
  742. ;; edebug-form-specs for Guido Bosch's flavors
  743.  
  744. (def-edebug-spec defmethod defun) ; same as defun
  745. (def-edebug-spec defwhopper defun) ; same as defun
  746.  
  747. ;;======================
  748. ;; Check syntax errors.
  749.  
  750. (defun test-too-many-arguments ()
  751.   (mapcar 'test one two))
  752.  
  753. (mapcar 'not-enough)
  754.  
  755. (defun test-not-enough-arguments ()
  756.   (mapcar 'test))
  757.  
  758. (defun test-bad-function ()
  759.   (function))
  760.  
  761. (defun test-bad-function ()
  762.   (function
  763.    (bad () )))
  764.  
  765. (defun test-bad-lambda-arguments ()
  766.   (function (lambda "bad" )))
  767.  
  768. (defun test-bad-defun-arguments "bad"
  769.   (function (lambda "bad" )))
  770.  
  771. (defun test-bad-defun-arguments (arg "bad")  ;; wrong error
  772.   (function (lambda "bad" )))
  773.  
  774. (defun test-bad-defun-arguments (&optional)
  775.   (function (lambda "bad" )))
  776.  
  777. (defun test-bad-let-in-lambda ()
  778.   (function (lambda ()
  779.           (let ((something one bad))))))  ;; wrong error
  780.  
  781. (defun test-bad-interactive ()
  782.   (interactive one bad))
  783.  
  784. (defun test-bad-defvar ()
  785.   (defvar test-defvar nil [bad]))
  786.  
  787. (defun test-bad-let1 ()
  788.   (let bad))
  789.  
  790. (defun test-bad-let2 ()
  791.   (let ((something one bad))))
  792.  
  793. (defun test-good-let ()
  794.   (let ((a b))))
  795.  
  796. (defun test-bad-let3 ()
  797.   (let (((bad)))))
  798.  
  799. (defun test-bad-let4 ()
  800.   (let ("bad")))
  801.  
  802. (let ((good (list 'one))) good)
  803.  
  804. (defun test-bad-setq ()
  805.   (setq "bad" ))
  806.  
  807. (setq good ok 
  808.       "bad")
  809.  
  810. (defun test-bad-cond ()
  811.   (cond "bad"))
  812.  
  813. (cond ())
  814.  
  815. (defun test-bad-cond ()
  816.   (cond () [] "bad"))
  817.  
  818. (defun test-bad-condition-case1 ()
  819.   (condition-case "bad"))
  820.  
  821. (defun test-bad-condition-case2 ()
  822.   (condition-case err
  823.       nil
  824.     "bad"))
  825.  
  826. (defun test-bad-condition-case3 ()
  827.   (condition-case err
  828.       (error "messages")
  829. ;;    ()
  830.     ((error quit) (message "%s" err))))
  831.  
  832.  
  833. (def-edebug-spec do
  834.   ((&rest &or symbolp
  835.            (fence symbolp &optional form form))
  836.    (form body) body))
  837.  
  838. (defun bad-do (list)
  839.  
  840. (do (     x
  841.        (x list (cdr x))
  842.      (y nil (cons (car x) y))
  843.      (x list (cdr x) bad)
  844.      "bad"
  845.      )
  846.       ((endp x) y)
  847.     ))
  848.  
  849. (defun ok ()
  850.   test
  851.   )
  852.  
  853. (defun "bad" () )
  854. (defun)
  855.  
  856. ;;=========================
  857.  
  858. ;; Test printing.
  859.  
  860. (defun test-window-buffer-change (arg)
  861.   "testing"
  862.   (interactive arg)
  863.   (save-window-excursion
  864.     (set-window-buffer (selected-window) (get-buffer "*scratch*"))
  865.     (get-buffer-window (current-buffer))))
  866. (test-window-buffer-change 'test)
  867.  
  868.  
  869. (defun test-window-buffer-change ()
  870.   (selected-window))
  871.  
  872. (test-window-buffer-change 1)
  873.  
  874. arg
  875.  
  876.  
  877. (def-edebug-spec edebug-forms
  878.   (&rest edebug-form))
  879.  
  880. (def-edebug-spec edebug-form
  881.   (&or (edebug-function-symbolp edebug-forms)
  882.        (anonymous-function edebug-forms)
  883.        (edebug-macro-symbolp 
  884.        sexp)))
  885.  
  886.  
  887. (defun test-mapatoms () )
  888.  
  889. (mapatoms (function (lambda (arg) 
  890.               (princ 
  891.                arg)
  892.               )))
  893.  
  894.  
  895. (test-mapatoms)
  896.  
  897. ;; Test embedded &rest
  898. (def-edebug-spec symbol-list
  899.   ([&rest "a" symbolp] form))
  900.  
  901. (defun test ()
  902.   (symbol-list a b a (+ c d)))
  903. (test)
  904.  
  905. (def-edebug-spec group-alternates-test
  906.   (&or ["foo" "bar"] "baz"))
  907.  
  908. (group-alternates-test foo bar)
  909. (group-alternates-test baz )
  910.  
  911. ;;---------------------
  912.  
  913. (defun test ()
  914.   (dolist (f (list 1 2))
  915.       (message f)))
  916.  
  917. (defun test ()
  918.   (dolist (el (list 'a 'b 'c))
  919.     (print el)))
  920.  
  921.  
  922. ;; (of-type (type (more type)))
  923.  
  924. (def-edebug-spec test-nil
  925.   (&or symbolp "nil"))
  926. (test-nil () )
  927.  
  928. (defun test ()
  929.   ((lambda (arg) arg) two)
  930. )
  931.  
  932.  
  933. ;; Dot notation testing
  934.  
  935. (def-edebug-spec test-dot
  936.   (symbolp . [&or symbolp (stringp)]))
  937. (test-dot xyz . jk)
  938. (test-dot xyz "jk")
  939.  
  940. (def-edebug-spec test-dot
  941.   (&or symbolp (test-dot1)))
  942.  
  943. (def-edebug-spec test-dot1 
  944.   (test-dot2 . test-dot2))
  945.  
  946. (def-edebug-spec test-dot2
  947.   (symbolp))
  948.  
  949. (def-edebug-spec test-dot2
  950.   ([&or test-dot1 nil]))
  951.  
  952. (def-edebug-spec test-dot1
  953.   (symbolp))
  954.  
  955.   (&or symbolp (test-dot)))
  956.  
  957.  
  958. (defun test ()
  959.   (test-dot (a . b)))
  960.  
  961. (def-edebug-spec edebug-specs
  962.   (symbolp . symbolp))
  963.  
  964. (def-edebug-spec edebug-specs1
  965.   (&or symbolp))
  966.  
  967. (def-edebug-spec edebug-spec
  968.   (&or
  969.    symbolp))
  970.  
  971.  
  972. (def-edebug-spec test-not
  973.   (symbolp . [¬ symbolp form]))
  974. (test-not "string")
  975.  
  976. ;;--------------------------
  977. ;; Loop macro testing
  978.  
  979. (defun test ()
  980.   (loop-var (((var1 (var2 var4) . (var3 var5)) . var1))
  981.         ))
  982.  
  983. (loop-var (var1 var2 . var3))
  984. (loop-var (var1 ["bad"] . "bad"))
  985.  
  986.             '        (var2 var3 . var4))
  987.  
  988. (loop for ((a . b) (c . d))
  989.       of-type ((float . float) (integer. integer))
  990.       )
  991.  
  992. (defun test ()
  993.   (loop if some-test
  994.            collect a-form into var
  995.     else minimize x ;; of-type some-type
  996.          and append x
  997.     end))
  998.  
  999. (defun test ()
  1000.   (loop for x from 1 to 9
  1001.     and y = nil then x
  1002.     collect (list x y)))
  1003.  
  1004. (defun test ()
  1005.   (loop for i from 10 downto 1 by 3
  1006.     do (print i)))
  1007.  
  1008.  
  1009. (defun test ()
  1010.   (loop for item = 1 then (+ item 10)
  1011.     repeat 5
  1012.     collect item))
  1013.  
  1014. (defun test ()
  1015.   (loop for z upfrom 2
  1016.     thereis
  1017.     (loop for n upfrom 3 below (+ z 2) ;; + was log
  1018.           thereis
  1019.           (loop for x below z
  1020.             thereis
  1021.             (loop for y below z
  1022.               thereis (= (+ (* x n) ;; * was expt
  1023.                     (* y n))
  1024.                      (* z n)))))))
  1025.  
  1026. (defun test ()
  1027.   (loop for name in '(fred sue alice joe june)
  1028.     as age in '(22 26 19 20 10)
  1029.     append (list name age) into name-and-age-list
  1030.     count name into name-count
  1031.     sum age into total-age
  1032.     finally
  1033.     (return (values (round* total-age name-count)
  1034.             name-and-age-list))))
  1035.  
  1036. (defun test ()
  1037.   (loop for x from 0 to 3
  1038.     do (print x)
  1039.     if (zerop (mod x 2))
  1040.     do (princ " a")
  1041.     and if (zerop (floor* x 2))
  1042.     do (princ " b")
  1043.     end
  1044.     and do (princ " c")))
  1045.  
  1046.  
  1047. (defun test ()
  1048.   (loop initially do (message x)
  1049.     do (dispatch-event event)))
  1050.  
  1051. (defun test ()
  1052.   (loop initially do (popup-menu menu)   ;; do is an error here.
  1053.     with event = (allocate-event)
  1054.     do (dispatch-event event)))
  1055.  
  1056. (defun popup-menu-synchronously (menu)
  1057.   (loop initially (popup-menu menu) 
  1058.     with event = (allocate-event)
  1059.     until (button-release-event-p (next-event event))
  1060.     do (dispatch-event event)
  1061.     finally do (deallocate-event event)))
  1062.  
  1063. (defun test ()
  1064.    (loop with list = '(1 2 3 4)
  1065.          for item in list
  1066.          sum item into summation
  1067.          collect (list item)))
  1068.  
  1069. ;;----------
  1070.  
  1071. (defun test-catch (n)
  1072.   (if (> n 0)
  1073.       (let* ((test
  1074.           (catch 'test
  1075.         (test-catch (1- n)))))
  1076.     (if test
  1077.         (do-throw)))
  1078.     (do-throw)))
  1079.  
  1080. (defun do-throw ()
  1081.   (funcall 'throw 'test 'here))
  1082.  
  1083. (test-catch 3)
  1084.  
  1085.  
  1086. ;;------------
  1087.  
  1088. (defun* foo (a &optional b &key c d (e 17)))
  1089.  
  1090. (def-edebug-spec test-vector
  1091.   ((vector form)))
  1092.  
  1093. (defun test ()
  1094.  
  1095.   (test-vector [one]))
  1096.  
  1097. [testing one two three]
  1098. (testing one two three)
  1099.  
  1100. (def-edebug-spec test
  1101.   (&optional &or ["something" keywordp] symbolp))
  1102.  
  1103. (test something :somekey)
  1104.  
  1105. ;;----------
  1106.  
  1107.  
  1108.  
  1109. (defun find-faq (filename)
  1110.   "Hmtar en faq."
  1111.   (interactive 
  1112.  
  1113.    (list 
  1114.     (all-faq-a-valid-ftp
  1115.      (intern-soft
  1116.       (let ((minibuffer-help-form
  1117.          (function
  1118.           (let* ((partial (buffer-string))
  1119.              (soft (intern-soft partial all-faq-known-files)))
  1120.         (if soft
  1121.             (set soft (append (cdr (symbol-value soft)) 
  1122.                       (list (car (symbol-value soft))))))
  1123.         (if (and soft (all-faq-a-valid-ftp soft))
  1124.             (mapconcat 
  1125.              (function
  1126.               (lambda (apair)
  1127.             (car apair)))
  1128.              (symbol-value soft)
  1129.              "\n"))))))
  1130.     (completing-read "What faq? "
  1131.              all-faq-known-files
  1132.              (function all-faq-a-valid-ftp)
  1133.              t ""))
  1134.       all-faq-known-files)))
  1135. )
  1136.   (find-file filename))
  1137.  
  1138.  
  1139. ;;===============
  1140.  
  1141. ;; Keyword testing
  1142.  
  1143. (def-edebug-spec test
  1144.   (&key (bad "one") (good "thing")))
  1145. (defun test-key ()
  1146.   (test :bad one)
  1147.   (test1 :bad one))
  1148.  
  1149. (def-edebug-spec test
  1150.   (("one")))
  1151.  
  1152.   (&rest ["one" "two"]))
  1153.  
  1154. (test (one))
  1155.  
  1156. (progn (message "one" ) )
  1157. (testet  xxx)
  1158. (progn (message "one" ) )
  1159.  
  1160. (let ((a (+ 1 1)))
  1161.   (1+ a))
  1162.  
  1163. (mapcar 'test (list 1 2 3))
  1164. (defun test (testing) testing)
  1165.  
  1166. ;;==================
  1167. ;; Test defstruct.
  1168.  
  1169. (defun test ()
  1170.   (defstruct 
  1171.     (test (:constructor construct (args)))
  1172.     a
  1173.     (b (+ a c))
  1174.     c))
  1175.  
  1176. ;;================
  1177. ;; advice
  1178.  
  1179. (defun foo (x)
  1180.   "Add 1 to x."
  1181.   (1+ x))
  1182.  
  1183. (require 'advice)
  1184.  
  1185. (defadvice foo (before add2 first activate)
  1186.   "  Add 2 to x"
  1187.   (setq x (1+ x)))
  1188.  
  1189. (foo 3)
  1190.